COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00005 00003
C00008 00004
C00010 00005
C00012 ENDMK
C⊗;


(SETQ BASE (SETQ IBASE 10.)) 

(SETQ *NOPOINT T) 

;A**N MOD M
(DEFUN SEX (A N M) 
       (PROG (BITS NEXT RESULT) 
	     (SETQ BITS (LFY N))
	     (SETQ NEXT A)
	     (SETQ RESULT 1.)
	     (SETQ BASE (SETQ IBASE 10.))
	LOOP (COND ((NULL BITS) (RETURN RESULT))
		   ((CAR BITS)
		    (SETQ RESULT (REMAINDER (TIMES RESULT NEXT) M))))
	     (SETQ BITS (CDR BITS))
	     (SETQ NEXT (REMAINDER (TIMES NEXT NEXT) M))
	     (GO LOOP))) 

(DEFUN TEST1 (A P) (EQUAL 1. (SEX A (SUB1 P) P))) 

(DEFUN SEARCH (START DIRECT PROB) 
       (PROG (FOUNDANY STEP NESS) 
	     (SETQ START (COND ((ZEROP (REMAINDER START 2.))
				(ADD1 START))
			       (T START)))
	     (SETQ STEP (COND ((MINUSP DIRECT) -2.) (T 2.)))
	     (DO ((I 0. (PLUS I STEP)))
		 ((GREATERP (ABS I) (ABS DIRECT)) 'DONE)
		 (SETQ K (PLUS I START))
		 (SETQ NESS (COND ((GREATERP K 16987141552.)
				   16987141551.)
				  (T (SUB1 K))))
		 (DO ((J 1. (ADD1 J)))
		     ((OR (NOT (TEST1 (ADD1 (RANDOM NESS)) K))
			  (GREATERP J PROB))
		      (COND ((GREATERP J PROB)
			     (PRINT K)
			     (SETQ FOUNDANY (CONS K FOUNDANY)))))))
	     (RETURN (REVERSE FOUNDANY)))) 

(DEFUN CH (A K P) 
       (PROG (PROD) 
	     (SETQ PROD (TIMES K P))
	     (RETURN (DIFFERENCE (SEX A PROD PROD) (SEX A K PROD))))) 

(DEFUN PT (N) (SEARCH N 1. 20.)) 

(DEFUN LFY (N) 
       (DO ((BN (COND ((BIGP N) (REVERSE (CDR N))) (T (LIST (ABS N))))
		(CDR BN))
	    (J)
	    (START))
	   ((NULL BN) J)
	   (DO ((I 1. (ADD1 I)) (K (LSH (CAR BN) 1.) (LSH K 1.)))
	       ((EQUAL I 36.))
	       REDOIT
	       (COND (START (SETQ J (CONS (COND ((MINUSP K) T)
						(T NIL))
					  J)))
		     ((MINUSP K) (SETQ START T) (GO REDOIT)))))) 

(DEFUN CLEAN (L) 
       (COND ((NULL L) NIL)
	     ((NULL (CDR L)) L)
	     ((= (CAR L) (CADR L)) (CLEAN (CDR L)))
	     (T (CONS (CAR L) (CLEAN (CDR L)))))) 

(DEFUN FF (N D) 
       (COND ((EQUAL N D) (LIST N))
	     ((ZEROP (REMAINDER N D)) (CONS D (FF (QUOTIENT N D) D)))
	     ((GREATERP D (QUOTIENT N D)) (LIST N))
	     ((= D 2.) (FF N 3.))
	     (T (FF N (PLUS D 2.))))) 

(DEFUN FL (N) (CLEAN (FF N 2.))) 

(SETQ PRIMELIST '(2. 3. 5. 7.)) 

(DEFUN LIST-PRIMES (LIMIT) 
       (PROG (RPLIST TRP D PL) 
	     (SETQ RPLIST (REVERSE PRIMELIST))
	     (SETQ TRP (CAR RPLIST))
	NEXT (SETQ TRP (PLUS 2. TRP))
	     (COND ((GREATERP TRP LIMIT)
		    (SETQ PRIMELIST (REVERSE RPLIST))
		    (RETURN (LENGTH PRIMELIST))))
	     (SETQ PL PRIMELIST)
	LOOP (SETQ D (CAR PL) PL (CDR PL))
	     (COND ((GREATERP D (QUOTIENT TRP D))
		    (SETQ RPLIST (CONS TRP RPLIST))
		    (GO NEXT))
		   ((ZEROP (REMAINDER TRP D)) (GO NEXT))
		   (T (GO LOOP))))) 

(DEFUN RUNP (START) 
       (PROG (PM M PL FT) 
	     (SETQ M START)
	NEXT (SETQ PM M PL F-LIST)
	LOOP (SETQ CPL (CAR PL) 
		   PL (CDR PL) 
		   M (ADD1 (SETQ M1 (TIMES PM (CAR CPL)))))
	     (COND ((EQUAL (SEX 3. M1 M) 1.)
		    (PRINT (LIST M
				 CPL
				 (SETQ FT
				       (FTEST M
					      M1
					      (CONS PM (CDR CPL))))))
		    (COND (FT (GO NEXT)) (T (GO LOOP))))
		   (T (GO LOOP))))) 

(DEFUN RUNP2 (START) 
       (PROG (PM M PL FT) 
	     (SETQ M START PM M)
	NEXT (SETQ PPM PM PM M PL F-LIST)
	LOOP (SETQ CPL (CAR PL) 
		   PL (CDR PL) 
		   M (ADD1 (SETQ M1 (TIMES PPM PM (CAR CPL)))))
	     (COND
	      ((EQUAL (SEX 3. M1 M) 1.)
	       (PRINT (LIST M
			    CPL
			    (SETQ FT
				  (FTEST M
					 M1
					 (CONS PPM
					       (CONS PM
						     (CDR CPL)))))))
	       (COND (FT (GO NEXT)) (T (GO LOOP))))
	      (T (GO LOOP))))) 

(LIST-PRIMES 40.) 

(SETQ KPL PRIMELIST) 

(SETQ KPL PRIMELIST) 

(LIST-PRIMES 200.) 

(DEFUN FTEST (M M1 CCPL) 
       (PROG NIL 
	LOOP (COND ((NULL CCPL) (RETURN T))
		   ((NOT (FTEST4 M M1 (CAR CCPL))) (RETURN NIL)))
	     (SETQ CCPL (CDR CCPL))
	     (GO LOOP))) 

(DEFUN MAKE-LIST (N) 
       (PROG NIL 
	     (SETQ F-LIST NIL)
	LOOP (SETQ F-LIST (CONS (CONS (TIMES 2. N) (FL (TIMES 2. N)))
				F-LIST))
	     (COND ((EQUAL N 1.) (RETURN 'DONE)))
	     (SETQ N (SUB1 N))
	     (GO LOOP))) 

(DEFUN FTEST4 (M M1 P) 
       (PROG (LPL) 
	     (SETQ LPL KPL)
	LOOP (COND ((NULL LPL) (RETURN NIL))
		   ((EQUAL (CAR LPL) P)
		    (SETQ LPL (CDR LPL))
		    (GO LOOP))
		   ((NOT (EQUAL (SEX (CAR LPL) (QUOTIENT M1 P) M) 1.))
		    (RETURN (EQUAL (SEX (CAR LPL) M1 M) 1.)))
		   (T (SETQ LPL (CDR LPL)) (GO LOOP))))) 

(SETQ F-LIST NIL) 

(MAKE-LIST 100.) 

(DEFUN TP (M) 
       (AND (EQUAL (SEX 3. (SUB1 M) M) 1.)
	    (FTEST M (SUB1 M) (FL (SUB1 M))))) 

(DEFUN PS (N) 
       (DO ((I 1. (ADD1 I))
	    (J PRIMELIST (CDR J))
	    (K 2. (TIMES K (CADR J))))
	   ((EQUAL I N) K))) 

(DEFUN TP1 (M L) 
       (AND (EQUAL (SEX 3. (SUB1 M) M) 1.)
	    (FTEST M (SUB1 M) (APPEND L (FL (CUTDOWN (SUB1 M) L)))))) 

(DEFUN CUTDOWN (M1 L) 
       (COND ((NULL L) M1)
	     (T (CUTDOWN (QUOTIENT M1 (CAR L)) (CDR L))))) 
βββββ